home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
CD ROM Paradise Collection 4
/
CD ROM Paradise Collection 4 1995 Nov.iso
/
program
/
4cmp22s.zip
/
ASM.SCR
< prev
next >
Wrap
Text File
|
1994-10-30
|
34KB
|
1 lines
( 8086 assembler 06:22 11/10/85 ) ( Last change: Screen 022 15:19 03/01/86 ) Contents copyright (C) 1985 by Thomas Almy. All rights reserved. This assembler is compatible with the CFORTH 8086 assembler. Purchasers of CFORTH may use this assembler to assist in developing programs using a Forth interpreter for later compilation with CFORTH, since it conforms with that assembler. Additions and exceptions are noted on the following screens LMI PC/FORTH 3.x is assumed in screen 3 and in the definitions of CODE NEXT, and ;CODE (especially concerning register useage) ( 22:15 11/18/85 ) --> Additions to assembler NEXT, -- Generates code to jump back to inner interpreter Use instead of RET or JMPI in CFORTH. Return address is automatically saved on return stack. IN/OUT -- When used, causes a code preamble to be generated by CODE and ;CODE, and different code by NEXT, so as to match the register interface of CFORTH (Arguments/ results in AX and BX, SI is free). NOIN/OUT -- No special code is generated. When neither IN/OUT or NOIN/OUT are used: a code preamble is generated by CODE and ;CODE, and different code by NEXT, so as to match the register interface of CFORTH (SI is free). CALL' name -- Generates code to do a threaded-call of "name". All arguments and results are passed on the stack. ( 06:32 11/10/85 ) --> Assembler exceptions 1. L: generates a header, thus taking space, so labels cannot be declared in the middle of executable code. 2. You cannot use the CALL or JMP instruction to go to another code word, (or high level, of course!). ( MAKE AN OVERLAY 18:00 01/21/86 ) 29 32 THRU ( headerless ) : OVERLAY ; 4 LOAD : ASMCF ; : OVERLAY ; 4 LOAD : ASMCF ; BSAVE OVERLAY ASMCF ( assembler for CForth ) FORGET OVERLAY FORGET OVERLAY EXIT Execute the following commands in PC/FORTH (or 8086 FORTH) to add the command ASMCF to your Forth system which will load the assembler when executed. : ASMCF HIDDEN " ASMCF BIN" ("BGET) FORTH ." Assembler loaded." CR ; SAVE FORTH ( LOAD THE ASSEMBLER 06:21 11/10/85 ) FORTH DEFINITIONS DECIMAL 5 28 THRU ASM CHOP.HEADS FORTH DEFINITIONS DECIMAL ( If loading from this screen, load the headerless extension, 29 32 THRU, first ) ( 8086 REGISTER DEFINITIONS 21:33 01/29/86 ) VOCABULARY ASM IMMEDIATE ASM DEFINITIONS HEX 0 CONSTANT AX 1 CONSTANT CX 2 CONSTANT DX 3 CONSTANT BX 4 CONSTANT SP 5 CONSTANT BP 6 CONSTANT SI 7 CONSTANT DI -1 CONSTANT [CL] -1 CONSTANT [DX] ( sometimes needed ) 0 CONSTANT ES 8 CONSTANT CS 10 CONSTANT SS 18 CONSTANT DS SEPVAR DSPHLD ( HOLDS DISPLACEMENTS ) SEPVAR LITHLD ( HOLDS LITERALS ) SEPVAR INSTR ( INSTRUCTION START ) SEPVAR INSPTR ( POINTER TO OPERATION PARMS ) SEPVAR BYTINS ( BYTE INSTRUCTION ) SEP: BREG CREATE , DOES> BYTINS ON @ ; 0 BREG AL 1 BREG CL 2 BREG DL 3 BREG BL 4 BREG AH 5 BREG CH 6 BREG DH 7 BREG BH : BYTE BYTINS ON ; ( sometimes needed ) ( 8086 REGISTER DEFINITIONS 06:43 11/10/85 ) SEP: DSPMOD CREATE C, DOES> C@ SWAP DSPHLD ! ; SEP: REGMOD CREATE C, DOES> C@ 0 DSPHLD ! ; 08 REGMOD [BX+SI] 09 REGMOD [BX+DI] 0A REGMOD [BP+SI] 0B REGMOD [BP+DI] 0C REGMOD [SI] 0D REGMOD [DI] 0E REGMOD [BP] 0F REGMOD [BX] 11 DSPMOD [] ( DIRECT ADDRESSING -- MODE 11 ) 08 DSPMOD +[BX+SI] 09 DSPMOD +[BX+DI] 0A DSPMOD +[BP+SI] 0B DSPMOD +[BP+DI] 0C DSPMOD +[SI] 0D DSPMOD +[DI] 0E DSPMOD +[BP] 0F DSPMOD +[BX] 10 EQU lit : # LITHLD ! lit ; ( LITERALS ARE MODE 10 ) ( ADDRESS FIELD COMPUTATION 18:17 03/05/86 ) SEP: SETINS HERE INSTR ! ; SEP: SETUP INSPTR ! SETINS ; SEP: BUMP 1 INSPTR +! ; SEP: 8* 8 * ; SEP: BYTE? BYTINS @ ; SEP: ?BYTE BYTE? IF BYTINS OFF 1- THEN ; SEP: SEGOVR CREATE 26 + C, DOES> SETINS C@ C, ; ES SEGOVR ES: CS SEGOVR CS: SS SEGOVR SS: DS SEGOVR DS: SEP: SETDIR ( ARG ARG -- REG/IMM ARG , DIR FLAG MAY BE SET) OVER 7 U> IF SWAP INSTR @ C@ 2+ INSTR @ C! THEN ; SEP: 1IM ( ONE IMMEDIATE ) DUP lit = IF DROP LITHLD @ DUP ABS 80 U< IF INSPTR @ C@ 2+ C, C, ELSE INSPTR @ C@ C, , THEN R> DROP ELSE BUMP THEN ; ( ADDRESS FIELD COMPUTATION 18:15 03/05/86 ) SEP: SETDSP ( value -- , set DSPHLD ) DUP 11 <> IF ." DIRECT ADDRESSING ASSUMED " DSPHLD ! ELSE DROP THEN ; SEP: ADRFLD ( REGISTER ARGUMENT -- ) DUP 8 U< IF ( REG-REG ) SWAP 8* + 0C0 + C, ELSE DUP 11 U< IF ( NOT DIRECT ) 8 - DSPHLD @ 0= OVER 6 <> AND IF ( no DISP ) SWAP 8* + C, ELSE DSPHLD @ ABS 80 U< IF ( short DISP ) SWAP 8* + 40 + C, DSPHLD @ C, ELSE ( long DISP ) SWAP 8* + 80 + C, DSPHLD @ , THEN THEN ELSE ( direct addressing ) SETDSP 8* 6 + C, DSPHLD @ , THEN THEN ; ( INSTRUCTION MODES 21:52 01/29/86 ) SEP: 0MD ( NO ARGS ) CREATE C, DOES> SETINS C@ C, ; SEP: 0MDB ( 0 args, byte possible ) CREATE C, DOES> SETINS C@ ?BYTE C, ; SEP: 1RG ( ONE REGISTER ) DUP 8 U< BYTE? 0= AND IF INSPTR @ C@ + C, R> DROP ELSE BUMP THEN ; SEP: 1MEM ( REG/MEMORY ) INSPTR @ DUP C@ ?BYTE C, 1+ C@ SWAP ADRFLD ; SEP: 1MD ( 1 arg, register or memory ) CREATE C, C, C, DOES> SETUP 1RG 1MEM ; ( INSTRUCTION MODES 21:59 01/29/86 ) SEP: 1MPU ( Push instruction, 80186 >= compatible ) CREATE C, C, C, C, DOES> SETUP 1IM 1RG 1MEM ; SEP: 1MDX ( 1 argument, no special register form ) CREATE C, C, DOES> SETUP 1MEM ; SEP: 1MDS ( shifts, this is 80186 >= compatible ) CREATE C, DOES> SETUP DUP [CL] = IF >R 0D3 ELSE DUP >R 1 = IF 0D1 ELSE 0C1 THEN THEN ?BYTE C, INSPTR @ C@ SWAP ADRFLD R> DUP 1 > IF C, ELSE DROP THEN ; SEP: 1MDIO ( io instructions ) CREATE C, DOES> SETUP DUP [DX] = IF INSPTR @ C@ 8 + ?BYTE C, DROP ELSE INSPTR @ C@ ?BYTE C, C, THEN ; ( INSTRUCTION MODES 21:59 01/29/86 ) SEP: 2IMA ( Immediate , accumulator destination ) 2DUP lit 0 D= IF 2DROP INSPTR @ C@ ?BYTE DUP C, LITHLD @ SWAP 1 AND IF , ELSE C, THEN R> DROP ELSE BUMP THEN ; SEP: 2IMRMA ( Immediate , register/memory destination, arith.) OVER lit = IF SWAP DROP INSPTR @ DUP C@ ?BYTE DUP >R C, 1+ C@ SWAP ADRFLD LITHLD @ R> 1 AND IF DUP ABS 80 U< IF INSTR @ C@ 2+ INSTR @ C! C, ELSE , THEN ELSE C, THEN R> DROP ELSE BUMP BUMP THEN ; ( INSTRUCTION MODES 21:59 01/29/86 ) SEP: 2IMRML ( immediate, reg/mem destination, logical ) OVER lit = IF SWAP DROP INSPTR @ DUP C@ ?BYTE DUP >R C, 1+ C@ SWAP ADRFLD LITHLD @ R> 1 AND IF , ELSE C, THEN R> DROP ELSE BUMP BUMP THEN ; SEP: 2MEM ( register to/from register/memory ) INSPTR @ C@ ?BYTE C, SETDIR ADRFLD ; ( INSTRUCTION MODES 06:57 11/10/85 ) SEP: 2MD ( immed to accum, immed to reg, reg to reg/mem, arith) CREATE C, C, C, C, DOES> SETUP 2IMA 2IMRMA 2MEM ; SEP: 2MDI ( immed to accum, immed to reg, reg to reg/mem, logic) CREATE C, C, C, C, DOES> SETUP 2IMA 2IMRML 2MEM ; SEP: 2MDN ( reg/mem to reg ) CREATE C, DOES> SETUP SWAP 2MEM ; ( INSTRUCTION MODES 21:17 01/30/86 ) SEP: 2MDM ( move, many modes! ) CREATE C, C, C, DOES> SETUP OVER 0= OVER 10 U> AND IF ( ACC TO MEM ) 0A3 ?BYTE C, SETDSP DSPHLD @ , DROP ELSE OVER 10 U> OVER 0= AND IF ( MEM TO ACC ) 0A1 ?BYTE C, DROP SETDSP DSPHLD @ , ELSE OVER lit = OVER 8 U< AND IF ( IMMED TO REG ) SWAP DROP LITHLD @ SWAP ( GET RIGHT ARGS ) BYTE? IF BYTINS OFF 0B0 ELSE 0B8 THEN SWAP OVER + C, 8 AND IF ( WORD ) , ELSE C, THEN ELSE ( imm to REG/MEM ) 2IMRML 2MEM THEN THEN THEN ; ( SEGMENT REGISTER INSTRUCTIONS, BRANCHES 06:59 11/10/85 ) SEP: 1SEG ( single segment register instruction ) CREATE C, DOES> SETINS C@ + C, ; SEP: 2SEG ( segment register and reg/mem, seg reg on top ) CREATE C, DOES> SETUP 8 / SWAP 2MEM ; ( BRANCH CONDITIONS ) 70 CONSTANT LOOPNZ 72 CONSTANT LOOP ( nus ) 8 CONSTANT <0 4 CONSTANT =0 2 CONSTANT <U 7 CONSTANT >U 0F CONSTANT >S 0C CONSTANT <S 0 CONSTANT OV ( overflow ) 0A CONSTANT PE ( even parity ) : ~ 1 XOR ; ( CHANGE SENSE STATE ) ( CALLS, FOR THE MOST PART 07:00 11/10/85 ) SEP: OFFSET HERE 1- - ; : CALL SETINS 0E8 C, OFFSET 3 - , ; ( CONDITIONAL JUMPS, UNCONDITIONAL JUMPS, 06:37 11/10/85 ) ( CONDITIONAL JUMP -- TARGET ADDRESS KNOWN ) : JMPC SETINS 70 + C, OFFSET 2- DUP ABS 7F U> ( OPS, NEED LONG FORM ) IF INSTR @ C@ ~ INSTR @ C! 3 C, 0E9 C, 3 - , ELSE C, THEN ; ( UNCONDITIONAL JUMP -- TARGET ADDRESS KNOWN ) : JMP SETINS DUP 10 U< IF FF C, 4 SWAP ADRFLD ELSE 0EB C, ( RELATIVE ADDRESS ) OFFSET 2- DUP ABS 7F > ( OPS, NEED LONG FORM ) IF 0E9 INSTR @ C! 1- , ELSE C, THEN THEN ; ( CONDITIONAL JUMP -- TARGET ADDRESS UNKNOWN, USE SHORT FORM ) : JMPCF SETINS 70 + C, 0 C, INSTR @ ; ( UNCONDITIONAL JUMP -- TARGET ADDRESS UNKNOWN, FORCE LONG JMP) : JMPF HERE 300 + JMP ; ( FORWARD JUMP RESOLUTION 06:39 11/10/85 ) SEP: RESOLVE ( JMPINSTRADDR TARGET -- ) OVER - OVER C@ 0E9 = IF ( UNCOND. LONG) 3 - SWAP 1+ ! ELSE DUP ABS 80 < IF ( GOOD CASE ! ) 2- SWAP 1+ C! ELSE -1 ABORT" branch target out of range " 2DROP THEN THEN ; ( NILADIC OPERATIONS 15:18 03/01/86 ) 8 BASE ! 231 0MD CWD 303 0MD RET 230 0MD CBW ( nu ) 317 0MD IRET 362 0MD REPNZ 363 0MD REPZ ( nus ) 245 0MDB MOVS 247 0MDB CMPS ( nus ) 257 0MDB SCAS 255 0MDB LODS ( same ) 253 0MDB STOS 374 0MD CLD 375 0MD STD 372 0MD CLI 373 0MD STI 370 0MD CLC 365 0MD CMC 371 0MD STC ( MONADIC OPERATIONS 22:07 01/29/86 ) 06 377 120 150 1MPU PUSH 00 217 130 1MD POP 06 1SEG PUSHSEG 07 1SEG POPSEG 00 377 100 1MD INC 01 377 110 1MD DEC 02 377 1MDX CALLI 04 377 1MDX JMPI 04 367 1MDX MUL 05 367 1MDX IMUL 06 367 1MDX DIV 07 367 1MDX IDIV 03 367 1MDX NEG 02 367 1MDX NOT ( MONADIC OPERATIONS 22:08 01/29/86 ) 04 1MDS SHL 05 1MDS SHR 07 1MDS SAR 00 1MDS ROL 01 1MDS ROR 02 1MDS RCL 03 1MDS RCR ( nus) 345 1MDIO IN 347 1MDIO OUT ( MONADIC OPERATIONS 15:19 03/01/86 ) : INT DUP 3 = IF 314 C, DROP ELSE 315 C, C, THEN ; HEX : XCHG SETINS 2DUP U< IF SWAP THEN DUP 0= BYTE? 0= AND IF OVER 8 U< IF DROP 90 + C, EXIT THEN THEN 87 ?BYTE C, SWAP ADRFLD ; 8 BASE ! ( DIADIC OPERATIONS 22:11 01/29/86 ) 001 00 201 005 2MD ADD 051 05 201 055 2MD SUB 021 02 201 025 2MD ADC ( nus ) 031 03 201 035 2MD SBB ( nus ) 071 07 201 075 2MD CMP 041 04 201 045 2MDI AND 205 00 367 251 2MDI TEST 011 01 201 015 2MDI OR 061 06 201 065 2MDI XOR ( DIADIC OPERATIONS 22:12 01/29/86 ) 216 2SEG >SEG ( copouts ) 214 2SEG <SEG 215 2MDN LEA 305 2MDN LDS ( nu ) 304 2MDN LES ( nu ) 211 00 307 2MDM MOV HEX ( BRANCH CONSTRUCTIONS 22:13 01/29/86 ) : IF, ( CC -- REF ) ~ JMPCF ; : THEN, ( REF -- ) HERE RESOLVE ; : FWD, ( -- REF , uncond forward jmp, resolve with "then" ) JMPF HERE 3 - ; : ELSE, ( REF -- REF ) HERE 3 + RESOLVE FWD, ; : BEGIN, ( -- ADDR ) HERE ; : UNTIL, ( ADDR CC -- ) ~ JMPC ; : WHILE, IF, ; : REPEAT, SWAP JMP THEN, ; SEP: RESETASM ASM BYTINS OFF LITHLD OFF DSPHLD OFF ; ( WINDOW DRESSING 22:15 11/18/85 ) SEPVAR incnt SEPVAR outcnt incnt ON outcnt ON SEPVAR noinout FORTH DEFINITIONS : IN/OUT 2DUP MIN 0< >R 2DUP MAX 2 > R> OR ABORT" Bad IN/OUT specification" ASM outcnt ! incnt ! ; : NOIN/OUT ASM noinout ON ; : L: CREATE [COMPILE] ASM ; ASM DEFINITIONS : END-CODE [COMPILE] FORTH noinout OFF incnt ON outcnt ON ; : CALL' ASM HERE 6 + # SI MOV NEXT-LINK JMP ' , HERE 2+ , HERE 2+ , ; ( MORE WINDOW DRESSING 22:13 01/29/86 ) : NEXT, noinout @ 0= IF outcnt @ 0< IF ASM BP SP XCHG SI POP BP SP XCHG ELSE SI POP outcnt @ CASE 1 OF AX PUSH ENDOF 2 OF BX PUSH AX PUSH ENDOF ENDCASE THEN THEN NEXT-LINK JMP ; FORTH DEFINITIONS : CODE ( LMI Forth 3.1 compatible ) CREATE HERE DUP 2- ! [COMPILE] ASM ASM RESETASM noinout @ 0= IF incnt @ 0< IF BP SP XCHG SI PUSH BP SP XCHG ELSE incnt @ CASE 1 OF AX POP ENDOF 2 OF AX POP BX POP ENDOF ENDCASE SI PUSH THEN THEN ; ( STILL MORE WINDOW DRESSING 22:14 01/29/86 ) : ;CODE ?CSP UNSMUDGE COMPILE ;code R> DROP STATE OFF [COMPILE] ASM ASM RESETASM noinout @ 0= IF BX INC BX INC ( point to body ) incnt @ 0< IF BX PUSH ( body address is now on stack ) BP SP XCHG SI PUSH BP SP XCHG ELSE incnt @ CASE 0 OF ABORT" There must be at least one argument" ENDOF 1 OF BX AX MOV ENDOF 2 OF BX AX MOV BX POP ENDOF ENDCASE SI PUSH ( save IP ) THEN THEN ; IMMEDIATE ( Transient Separate Headers 07:24 01/08/86 ) VARIABLE FDP ( far DP ) VARIABLE FDP0 \ : SEP.HEADS ( #bytes --- ) 3500 LIMIT SWAP - DUP DUP FDP0 ! FDP ! \ ; : SEP.DOES> ( --- ) DOES> ( at runtime, stack = pfa of header ) @ STATE @ IF , ( compilation: compile true cfa ) ELSE EXECUTE THEN ; ( interpretation: execute true cfa ) ( SEP: separate header for colon def 18:02 02/02/85 ) : (SEP) HERE >R ( save true HERE ) FDP @ DP ! ( HERE -> far header area ) CREATE IMMEDIATE ( lay down header, set precedence ) R@ , ( store true cfa in pfa of header ) SEP.DOES> ( compile runtime for header ) HERE FDP ! ( update THERE ) R> DP ! ; ( HERE -> top of dictionary ) : SEP: ( --- ) (SEP) ['] . @ , ( compile runtime for : ) CURRENT @ CONTEXT @ [ HEX 71A , DECIMAL ] ( ?CLR_HASH ) CONTEXT ! ( fix vocs ) !CSP [COMPILE] ] ; ( compile rest of colon def ) ( CHOP.HEADS excise transient headers 23:19 02/01/85 ) : CHOP.HEADS ( --- ) FDP0 @ FDP ! ( THERE -> far header area ) CONTEXT @ ( --- lfa ) BEGIN DUP @ ?DUP ( -- lfa nfa ) WHILE N>LINK ( -- lfa lfa ) BEGIN DUP HERE U> WHILE @ N>LINK ( -- lfa lfa ) REPEAT DUP L>NAME ( -- lfa lfa nfa ) ROT ! ( -- lfa ) REPEAT DROP CLR_HASH ; ( clean hash table ) ( EQU SEP' [SEP'] 09:28 02/06/85 ) : LB ( --- ) ( just a far CREATE ) (SEP) [ ' FDP @ ] LITERAL , ; : SEPVAR LB 0 , ; : EQU ( n --- ) ( just a "far" CONSTANT ) (SEP) [ ' BL @ ] LITERAL , ( constant ) , ; : SEP' ( --- cfa ) ' >BODY @ ; : [SEP'] ( --- cfa ) SEP' [COMPILE] LITERAL ; IMMEDIATE